home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_cl1.c next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  11.1 KB  |  399 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_cl1.c */
  5.  
  6. #include "clos.h"
  7.  
  8.  
  9. node AccessorList;
  10. node ThisClass;
  11. node ThisSupers;
  12. node ThisInitargs;
  13.  
  14.  
  15. node defclass_alloclist();
  16. void defclass_chk_supers();
  17. void defclass_parse_def();
  18. int  defclass_parse_initform();
  19. int  defclass_parse_initarg();
  20. void defclass_mkaccessor();
  21. void defclass_chk_initarg();
  22.  
  23.  
  24. /* ( DEFCLASS nome (supers)
  25.      (
  26.      (nome :accessor nome :initform nome :initarg nome)
  27.      (................................................)
  28.      )
  29.    )
  30. */
  31. void lf_defclass LF_PARAMS
  32. {
  33.  /* CLASS_TYPE--> ( (superclasses) (initforms) (initargs) ) */
  34.  
  35.  node supers;
  36.  node initforms=NIL;
  37.  node initargs=NIL;
  38.  node prev_initforms;
  39.  node prev_initargs;
  40.  node ni=nin;
  41.  lsiz_t index;
  42.  
  43.  if(IS_CONS(nin)){
  44.     eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  45.     if(nout->type==P_VALUE || nout->type==P_UNBOUNDVALUE ||
  46.        nout->type==P_CLASS || nout->type==P_UNBOUNDCLASS )
  47.     {
  48.         if(HAS_CLASS(nout->node)){
  49.             error(E_CLASSREDEF,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nout->node);
  50.         }
  51.         ThisClass=nout->node;
  52.         if(IS_CONS(nin=CONSRIGHT(nin))){
  53.             supers=list_dup(CONSLEFT(nin),DUP_LASTNIL);
  54.         if(!IS_CONS(supers)){
  55.         /* se non si specificano superclassi allora si mette */
  56.         /* solo T ,invece se si specificano superclassi */
  57.         /* sono solo queste che vanno nella supers-list */
  58.         TYPE(supers=node_make())|=NT_IS_CONS;
  59.         CONSLEFT(supers)=T;
  60.         CONSRIGHT(supers)=NIL;
  61.         }else{
  62.             /* controlla la lista supers e vede se e' composta solo di nomi */
  63.                 defclass_chk_supers(supers);
  64.         }
  65.         ThisSupers=supers;      
  66.             index=1;          /* conta il numero del campo */
  67.             AccessorList=NIL; /* inizializza AccessorList */
  68.         nin=CONSLEFT(CONSRIGHT(nin));    
  69.             while(IS_CONS(nin)){
  70.          if(initforms==NIL){
  71.                     initforms=prev_initforms=node_make();
  72.                     ThisInitargs=initargs =prev_initargs =node_make();
  73.         }else{
  74.                     CONSRIGHT(prev_initforms)=node_make();
  75.                     CONSRIGHT(prev_initargs )=node_make();
  76.             prev_initforms=CONSRIGHT(prev_initforms);
  77.                     prev_initargs =CONSRIGHT(prev_initargs );
  78.                 }
  79.                 TYPE(prev_initforms)|=NT_IS_CONS;
  80.         TYPE(prev_initargs)|=NT_IS_CONS;
  81.                 CONSLEFT(prev_initforms)=CONSRIGHT(prev_initforms)=
  82.                 CONSLEFT(prev_initargs )=CONSRIGHT(prev_initargs )=NIL;
  83.                 /* scorre le definizioni */
  84.         defclass_parse_def(CONSLEFT(nin),&CONSLEFT(prev_initforms),&CONSLEFT(prev_initargs),index++);
  85.         nin=CONSRIGHT(nin);
  86.             }
  87.             /* alloca una lista di 3 elementi */
  88.             /* ( supers initforms initargs ) */
  89.             CLASS(nout->node)=defclass_alloclist(supers,initforms,initargs);
  90.             TYPE(nout->node)|=NT_HAS_CLASS;
  91.             nout->type=P_CLASS;
  92.         /* valida tutti gli accessor */
  93.             while(AccessorList!=NIL){
  94.               ni=CONSLEFT(AccessorList);
  95.               TYPE(ni)|=NT_HAS_FUNCTION;
  96.           AccessorList=CONSRIGHT(AccessorList);
  97.             }
  98.             return;
  99.         }
  100.         error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&ni);
  101.     }
  102.     ni=calc_pointer(nout);
  103.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&ni);
  104.  }
  105.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  106. }
  107.  
  108.  
  109. node defclass_alloclist(supers,initforms,initargs)
  110. node supers;
  111. node initforms;
  112. node initargs;
  113. {
  114.  node ret=node_make();
  115.  
  116.  CONSRIGHT(ret)=node_make();
  117.  CONSLEFT(ret)=supers;
  118.  CONSRIGHT(CONSRIGHT(ret))=node_make();
  119.  CONSLEFT(CONSRIGHT(ret))=initforms;
  120.  CONSLEFT(CONSRIGHT(CONSRIGHT(ret)))=initargs;
  121.  CONSRIGHT(CONSRIGHT(CONSRIGHT(ret)))=NIL;
  122.  
  123.  TYPE(ret)=
  124.  TYPE(CONSRIGHT(ret))=
  125.  TYPE(CONSRIGHT(CONSRIGHT(ret)))|=NT_IS_CONS;
  126.  
  127.  return ret;
  128. }
  129.  
  130. void defclass_chk_supers(supers)
  131. node supers;
  132. {
  133.  node tmp;
  134.  node s=supers;
  135.  while(IS_CONS(supers)){
  136.      if(IS_NAME(CONSLEFT(supers))&&HAS_NAME(CONSLEFT(supers))){
  137.        if(HAS_CLASS(CONSLEFT(supers))){    
  138.          /* ok CONSLEFT(supers) e' un nome di classe */
  139.      /* si controlla se appare precedentemente nella lista supers */
  140.      tmp=s;
  141.      while(tmp!=supers){
  142.            if(CONSLEFT(supers)==CONSLEFT(tmp))
  143.          error(E_SUPERDUP,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&CONSLEFT(supers));
  144.            tmp=CONSRIGHT(tmp);
  145.          }
  146.          supers=CONSRIGHT(supers);
  147.          continue;
  148.        }
  149.        error(E_UNBOUNDCLASS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&CONSLEFT(supers));
  150.      }
  151.     error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&CONSLEFT(supers));
  152.  }
  153. }
  154.  
  155.  
  156. void defclass_parse_def(def,initf,inita,index)
  157. node   def;
  158. node    *initf;
  159. node    *inita;
  160. lsiz_t index;
  161. {
  162.  node aux;
  163.  node nerr=def;
  164.  node accessor=node_alloc("ACCESSOR");
  165.  
  166.  /*
  167.     def= ( {name}?
  168.            :accessor accessor-procname
  169.            {:initform initform-sx }?
  170.            {:initarg { intargs-name | initargs_cname | initargs-ename }}?
  171.          )
  172.  */
  173.  if(IS_CONS(def)){
  174.    /* il nome e' totalmente inutile */
  175.    /* se c'e' lo si salta se non c'e' si passa oltre */
  176.    aux=CONSLEFT(def);
  177.    if(IS_NAME(aux)&&HAS_NAME(aux)){
  178.      if(IS_CONS(def=CONSRIGHT(def))){
  179.        aux=CONSLEFT(def);
  180.      }
  181.    }
  182.    /* ora aux deve contenere :ACCESSOR */
  183.    if(IS_VALUE(aux) && GET_VTYPE(aux)==NT_CNAME && CNAME(aux)==accessor){
  184.      if(IS_CONS(def=CONSRIGHT(def))){
  185.        aux=CONSLEFT(def);
  186.        /* aux deve contenere il nome dell' accessor */
  187.        if(IS_NAME(aux)&&HAS_NAME(aux)){
  188.          /* ora aux e' OK e gli si collega l'accessor */
  189.          defclass_mkaccessor(aux,index);
  190.          /* ora si controlla se ci sono nell' ordine: :INITFORM e :INITARG */
  191.          if(IS_CONS(def=CONSRIGHT(def))){
  192.            /* c'e' ancora qualcosa e def contiene il resto della lista */
  193.            if(defclass_parse_initform(def,initf)){
  194.              /* non e' :INITFORM */
  195.              if(defclass_parse_initarg(def,inita)){
  196.            /* non e' :INITARG */
  197.                error(E_DEFCLASSYNTAX,ERR_MERROR|ERR_PVOID|ERR_TBLVL,&nerr);
  198.              }
  199.              /* e' :INITARG  allora si ritorna */
  200.              /* inserendo NIL nella initf */
  201.              *initf=NIL;
  202.              return;
  203.            }
  204.            /* e' initform */
  205.            def=CONSRIGHT(CONSRIGHT(def));
  206.            /* def contiene il resto della lista */
  207.            if(IS_CONS(def)){
  208.              /* c'e' ancora qualcosa e puo' essere solo :INITARG */
  209.              if(defclass_parse_initarg(def,inita))
  210.                 /* non e' initarg: errore */
  211.                 error(E_DEFCLASSYNTAX,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nerr);
  212.              return;
  213.            }
  214.            /* c'e' solo initform si mette NIL in inita */
  215.            *inita=NIL;
  216.        return;
  217.          }
  218.          /* non ci sono ne initform ne initarg si mette NIL nella inta e intf*/
  219.          *inita=NIL;
  220.          *initf=NIL;
  221.          return;
  222.        }
  223.        /* l'accessor aux non e' un nome */
  224.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&aux);
  225.      }
  226.      error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nerr);
  227.    }
  228.    error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&aux);
  229.  }
  230.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&nerr);
  231. }
  232.  
  233.  
  234. int  defclass_parse_initform(def,initf)
  235. node def;
  236. node  *initf;
  237. {
  238.  /* def e' sicuramente un CONS */
  239.  /* si controlla se e' (:INITFORM sx) */
  240.  
  241.  node initform=node_alloc("INITFORM");
  242.  node aux;
  243.  node l;
  244.  
  245.  aux=CONSLEFT(def);
  246.  if(IS_VALUE(aux)&&GET_VTYPE(aux)==NT_CNAME&&CNAME(aux)==initform){
  247.    if(IS_CONS(def=CONSRIGHT(def))){
  248.      if(IS_CONS(CONSLEFT(def))){
  249.        l=list_dup(CONSLEFT(def),DUP_LASTNIL);
  250.      }else{
  251.         l=CONSLEFT(def);
  252.      }    
  253.      *initf=l;
  254.      return OK;
  255.    }
  256.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&def);
  257.  }
  258.  return ERROR;
  259. }
  260.  
  261. int  defclass_parse_initarg(def,inita)
  262. node def;
  263. node  *inita;
  264. {
  265.  /* def e' sicuramente un CONS */
  266.  /* si controlla se e' (:INITARG sx) */
  267.  /* sx deve essere un nome!=da NIL */
  268.  /* oppure in :nome o &nome */
  269.  
  270.  node initarg=node_alloc("INITARG");
  271.  node aux;
  272.  
  273.  aux=CONSLEFT(def);
  274.  if(IS_VALUE(aux)&&GET_VTYPE(aux)==NT_CNAME&&CNAME(aux)==initarg){
  275.    if(IS_CONS(def=CONSRIGHT(def))){
  276.      aux=CONSLEFT(def);
  277.      if(aux==NIL)
  278.        error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&NIL);
  279.      if( IS_NAME(aux) && HAS_NAME(aux) ){
  280.        defclass_chk_initarg(aux);
  281.        *inita=aux;
  282.        return OK;
  283.      }
  284.      if( IS_VALUE(aux) && 
  285.     ((GET_VTYPE(aux)==NT_CNAME) || (GET_VTYPE(aux)==NT_ENAME)) ){
  286.        defclass_chk_initarg(aux);
  287.        *inita=aux;
  288.        return OK;
  289.      }
  290.      error(E_BADARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&aux); 
  291.    }
  292.    error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&def);
  293.  }
  294.  return ERROR;
  295. }
  296.  
  297.  
  298. void defclass_mkaccessor(aux,index)
  299. node aux;
  300. lsiz_t index;
  301. {
  302.  /* aux e' un nome */
  303.  /* controlla che l'accessor non sia gia' stato definito */
  304.  /* se e' cosi' lo alloca ma */
  305.  /* non marca il tipo di aux cosi' se c'e' un errore l'accessor */
  306.  /* viene liberato */
  307.  /* alla fine si marcano comunque tutti gli accessor che finiscono in una */
  308.  /* lista */
  309.  
  310.  node n;
  311.  
  312.  /* aux e' un nome ma si controlla se non ha gia' un accessor */
  313.  /* collegato in modo da trovare errori di duplicazione */
  314.  /* di nomi di accessori di struttura */
  315.  if(HAS_FUNCTION(aux)&&IS_VALUE(FUNCTION(aux))&&
  316.     (GET_VTYPE(FUNCTION(aux))==NT_ACCESSOR))
  317.    error(E_ACCESSORREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&aux);
  318.  
  319.  /* si controlla ovviamente che non sia anche in AccessorList */
  320.  n=AccessorList;
  321.  while(n!=NIL){
  322.    if(CONSLEFT(n)==aux)
  323.       error(E_ACCESSORREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&aux);
  324.    n=CONSRIGHT(n);
  325.  }
  326.  
  327.  /* si alloca l'accessor */
  328.  TYPE(n=node_make())|=NT_IS_VALUE+NT_ACCESSOR;
  329.  ACCESSOR_NAME(n)=ThisClass;
  330.  ACCESSOR_FIELD(n)=index;
  331.  
  332.  FUNCTION(aux)=n;
  333.   
  334.  TYPE(n=node_make())|=NT_IS_CONS;
  335.  CONSLEFT(n)=aux;
  336.  CONSRIGHT(n)=AccessorList;
  337.  AccessorList=n;
  338.  
  339. }
  340.  
  341.  
  342.  
  343. void defclass_chk_initarg(inita)
  344. node inita;
  345. {
  346.  node s=ThisSupers;
  347.  node cs;
  348.  node c;
  349.  
  350.  
  351.  /* controlla le duplicazioni degli initarg nelle superclassi */
  352.  /* s e' una lista di nomi con classe */
  353.  while(IS_CONS(s)){
  354.     cs=CONSLEFT(s);
  355.     if(cs==T){ /* salta T */
  356.       s=CONSRIGHT(s);
  357.       continue;
  358.     }
  359.     cs=CONSLEFT(CONSRIGHT(CONSRIGHT(CLASS(cs))));
  360.     /* cs=lista di initargs della superclasse s */  
  361.     while(IS_CONS(cs)){
  362.         c=CONSLEFT(cs);
  363.         if(IS_VALUE(inita)&&IS_VALUE(c)){
  364.             if(GET_VTYPE(inita)==GET_VTYPE(c)){
  365.         /* tutti e 2 cname o ename */
  366.                 if(NODE(inita)==NODE(c))
  367.                    error(E_INITARGREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&inita);
  368.             }
  369.         }else{
  370.           /* allora sono tutti e 2 dei nomi */
  371.           if(c==inita)
  372.             error(E_INITARGREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&inita);
  373.         }
  374.         cs=CONSRIGHT(cs);
  375.     }
  376.     s=CONSRIGHT(s);
  377.  }
  378.  
  379.  /* si controllano anche le duplicazioni 'locali' */
  380.  /* cs=lista di initargs della superclasse s */
  381.  cs=ThisInitargs;
  382.  while(IS_CONS(cs)){
  383.      c=CONSLEFT(cs);
  384.      if(IS_VALUE(inita)&&IS_VALUE(c)){
  385.          if(GET_VTYPE(inita)==GET_VTYPE(c)){
  386.              /* tutti e 2 cname o ename */
  387.              if(NODE(inita)==NODE(c))
  388.                 error(E_INITARGREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&inita);
  389.          }
  390.      }else{
  391.        /* allora sono tutti e 2 dei nomi */
  392.        if(c==inita)
  393.          error(E_INITARGREDEF,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&inita);
  394.      }
  395.      cs=CONSRIGHT(cs);
  396.  }
  397. }
  398.  
  399.